%%% ====================================================================
%%% translates a data structure of a pre-defined form to an XML document.
%%% 
%%% Copyright (C) 2006 Willem de Jong
%%%
%%% This program is free software; you can redistribute it and/or modify
%%% it under the terms of the GNU General Public License as published by 
%%% the Free Software Foundation; either version 2 of the License, or 
%%% (at your option) any later version.
%%%
%%% This program is distributed in the hope that it will be useful, but
%%% WITHOUT ANY WARRANTY; without even the implied warranty of
%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
%%% General Public License for more details.
%%%
%%% You should have received a copy of the GNU General Public License 
%%% along with this program; if not, write to the Free Software 
%%% Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
%%% USA
%%%
%%% Author contact: w.a.de.jong@gmail.com
%%% ====================================================================

%%% Version: 0.0.3

%%% This is the companion of erlsom_parse, which performs the inverse operation.
%%% Both modules use the same 'model' that descibes the translation, see the 
%%% introduction to erlsom_parse for the definition of this model.

-module(erlsom_write).
-export([write/2]).

-include("erlsom_parse.hrl").
-include("erlsom.hrl").

%% debug(Text) ->
  %% io:format("~p\n", [Text]).


%% Returns the XML document. {ok, Document}
write(Struct, Model = #model{tps = Types}) ->

  %% start with _document type. 
  case lists:keysearch('_document', 2, Types) of
    {value, #type{els = [Head | _Tail]}} ->
      CurrentValue = Struct,
      ResultWithThisElement = processElementValues([CurrentValue], Head, [], 0, Model, {[], 0}),
      %% debug(ResultWithThisElement);
      {ok, lists:flatten(ResultWithThisElement)};
    _Else ->
      {error, "Model should have _document type"}
  end.

struct2xml(_Struct, [], ResultSoFar, _Model, _Namespaces) ->
  lists:flatten(lists:reverse(ResultSoFar));

%% Struct = {RecordType, value, ...}
%% Processes whatever is INSIDE the tags (= the values of the struct), one by one, from the first
struct2xml(Struct, 
           _StructModel = [ModelForThisElement = #el{alts = Alternatives, mn = Min, mx = Max, nr = SequenceNr} | 
                           NextElements], 
           ResultSoFar, Model = #model{nss = Namespaces}, DeclaredNamespaces) ->

  %% We are dealing with element nr given by SequnceNr + 2
  %% (n+2 because the 1st is the type name and the 2nd is the list of 'anyAttributes')
  %% Which alternative has been selected follows from the value of this element
  CurrentValue = element(SequenceNr + 2, Struct),
  %% value = tuple => subtype
  %% value = list of chars (integers) => text
  %% value = list (not string) of:
  %%              tuples => subtypes, element has maxOccurs > 1 OR alternative has maxOccurs > 1
  %%              strings => 
  %%              lists => element has maxOccurs > 1 AND alternative has maxOccurs > 1
  %% value == undefined -> no value provided
  %% etc.

  %% debug(CurrentValue),

  if 
    Max == 1 ->  
      case CurrentValue of  
        undefined ->
          if 
            Min > 0  -> throw({error, "No value provided for non-optional element"});
	    true -> true
          end,
          ResultForThisElement = [];
        [V1 | _] ->
          case V1 of  
            _ when is_integer(V1) -> %% CurrentValue is a string
              ResultForThisElement = printValue(CurrentValue, Alternatives, Namespaces, DeclaredNamespaces);
            _ when is_tuple(V1) -> 
              %% debug("alternative with MaxOccurs > 1"),
              ResultForThisElement = processAlternatives(CurrentValue, Alternatives, Model, DeclaredNamespaces)
          end;
        #qname{} ->
          ResultForThisElement = printValue(CurrentValue, Alternatives, Namespaces, DeclaredNamespaces);
        _ when is_tuple(CurrentValue) ->
          %% debug("subtype"),
          ResultForThisElement = 
                 processElementValues([CurrentValue], ModelForThisElement, [], 0, Model, DeclaredNamespaces);
        _ ->
          %% debug("simple type"),
          ResultForThisElement = printValue(CurrentValue, Alternatives, Namespaces, DeclaredNamespaces)
      end;
    true -> %% CurrentValue is a list, because Element has maxOccurs > 1. 
      if 
        is_list(CurrentValue); CurrentValue == undefined -> true;
        true -> throw({error, "value has to be a list"})
      end,
      if 
        CurrentValue == undefined ->
          ResultForThisElement = [];
        true ->
          ResultForThisElement = processElementValues(CurrentValue, ModelForThisElement, [], 0, Model, DeclaredNamespaces)
      end
  end,
      
  %% process remaining elements
  struct2xml(Struct, NextElements, [ResultForThisElement | ResultSoFar], Model, DeclaredNamespaces).


processElementValues([], 
                     _ModelForThisElement = #el{mn = Min}, 
                     ResultSoFar, Counter, _Model, _DeclaredNamespaces) ->
  if 
    Counter < Min ->
      throw({error, "Not enough values provided"});
    true -> 
      lists:flatten(lists:reverse(ResultSoFar))
  end;

%% ElemnentValues can be:
%% 
%% FirstElement can be:
%% - a tuple
%%    - for a value
%% - a string (list)
%%    - for a value
%% - a list of tuples:
%%    - for a sequence (or all, no need to distinguish) where the element has more values 
%%    - for a choice where the selected alternative has maxOccurs > 1
%% - a list of lists
%%    - for a choice with maxOccurs > 1 and an alternative with maxOccurs > 1
%%    - it could in theory be a list of lists of lists (etc.)? But not now, since choice in choice is 
%%      not supported.
processElementValues([V1 | NextValues], 
               ModelForThisElement = #el{alts = Alternatives, mx = Max}, 
               ResultSoFar, Counter, Model = #model{nss = Namespaces}, DeclaredNamespaces) ->

  %% debug("procesElementValues, counter = " ++ integer_to_list(Counter)),
  if 
    Counter >= Max ->    %% if Max == unbound the result of the test is false!
      throw({error, "Too many values provided"});
    true -> true
  end,
  case V1 of 
    _ when is_list(V1) ->
      V11 = hd(V1),
      case V11 of
        #qname{} -> 
          throw({error, "wrong type in value"}),
          ResultWithThisElement = [];
        _ when is_tuple(V11) -> 
          ResultForThisElement = processAlternatives(V1, Alternatives, Model, DeclaredNamespaces),
          ResultWithThisElement = [ResultForThisElement | ResultSoFar];
        _ when is_integer(V11) -> 
          %% debug("element w. MaxOccurs > 1; 1st value is a string"),
          ResultForThisElement = printValue(V1, Alternatives, Namespaces, DeclaredNamespaces),
          ResultWithThisElement = [ResultForThisElement | ResultSoFar];
        _ -> 
          throw({error, "wrong type in value"}),
          ResultWithThisElement = []
      end;
    #qname{} ->
      %% debug("element w. MaxOccurs > 1, (1st value is a qname)."),
      ResultForThisElement = printValue(V1, Alternatives, Namespaces, DeclaredNamespaces),
      ResultWithThisElement = [ResultForThisElement | ResultSoFar];
    _ when is_tuple(V1) ->
      %% debug("element w. MaxOccurs > 1, (1st value is a subtype)"),
      ResultForThisElement = processSubType(V1, Alternatives, Model, DeclaredNamespaces),
      ResultWithThisElement = [ResultForThisElement | ResultSoFar];
    _ ->
      %% debug("element w. MaxOccurs > 1, (1st value is a simple type)"),
      ResultForThisElement = printValue(V1, Alternatives, Namespaces, DeclaredNamespaces),
      ResultWithThisElement = [ResultForThisElement | ResultSoFar]
  end,
  processElementValues(NextValues, ModelForThisElement, ResultWithThisElement, Counter + 1, Model, DeclaredNamespaces).

%% returns a string that represents the value
processSubType(Value, Alternatives, Model = #model{tps = Types}, DeclaredNamespaces) ->
  RecordType = element(1, Value),
  Alternative = findAlternative(RecordType, Alternatives),
  Type = findType(RecordType, Types),
  processAlternativeValue(Value, 1, Alternative, Type, Model, DeclaredNamespaces).

processAlternatives(Values = [Value | _], Alternatives, Model = #model{tps = Types},  DeclaredNamespaces) ->
  %% See which alternative this is
  RecordType = element(1, Value),
  Alternative = findAlternative(RecordType, Alternatives),
  Type = findType(RecordType, Types),
  processAlternativeValues(Values, 0, Alternative, Type, Model, DeclaredNamespaces, []).

processAlternativeValues([], Count, #alt{mn = Min}, _Type, _Model, _Ns, Acc) ->
  if 
    Count < Min -> throw({error, "not enough values"});
    true -> lists:reverse(Acc)
  end;

processAlternativeValues([V1 | Tail], Count, Alternative, Type, Model, Ns, Acc) ->
  processAlternativeValues(Tail, Count + 1, Alternative, Type, Model, Ns, 
      [processAlternativeValue(V1, Count, Alternative, Type, Model, Ns) | Acc]).
  
processAlternativeValue(Value, Count, 
                        #alt{tag = Tag, rl = RealElement, mx = MaxAlt},
                        #type{els = Elements, atts = Attributes},
                        Model = #model{nss = Namespaces},
                        DeclaredNamespaces) ->
  if 
   Count > MaxAlt -> throw({error, "too many values"});
   true -> true
  end,

  if 
    RealElement ->
      %% proces the attributes
      {AttributesString, NewDeclaredNamespaces} = processAttributes(Value, [], Attributes, Namespaces, DeclaredNamespaces),
      %% process anyAttributes
      %% for now we don't check whether 'anyAttributes' are allowed!
      {AnyAttributesString, NewDeclaredNamespaces2} = processAnyAttributes(element(2, Value), [],
                                                      Namespaces, NewDeclaredNamespaces), 
      %% deal with namespaces (that is, see if they have to be declared here)
      TagAsText = atom_to_list(Tag),
      {NamespacesString, NewDeclaredNamespaces3} = processNamespaces(TagAsText, Namespaces, NewDeclaredNamespaces2),
      %% print startTag
      StartTag = "<" ++ TagAsText ++ NamespacesString ++ AttributesString ++ AnyAttributesString ++ ">";
    true -> 
      StartTag = [],
      NewDeclaredNamespaces3 = DeclaredNamespaces
  end,

  if 
    RealElement ->
      %% print end tag
      EndTag = "</" ++ atom_to_list(Tag) ++ ">";
    true ->
      EndTag = []
  end,

  %% process sub-elements - recursively!
  ResultForThisElement = struct2xml(Value, Elements, [], Model, NewDeclaredNamespaces3),
  [StartTag | [ResultForThisElement | EndTag]].


findType(TypeName, Types) ->
  case lists:keysearch(TypeName, #type.nm, Types) of
    {value, Type} -> Type;
    _ -> throw({error, "Something wrong with the Model"})
  end.

findAlternative(RecordType, Alternatives) ->
  case lists:keysearch(RecordType, #alt.tp, Alternatives) of
    {value, Alternative} -> Alternative;
    _ ->  throw({error, "Struct doesn't match model: recordtype not expected: " ++ atom_to_list(RecordType)})
  end. 
  

%% Attribute is a tuple {Name, SequenceNr, Optional, Type}
processAttributes(_Struct, ResultSoFar, [], _Namespaces, DeclaredNamespaces) ->
  {ResultSoFar, DeclaredNamespaces};

processAttributes(Struct, ResultSoFar, [#att{nm = Name, 
                                             nr = SequenceNr, 
                                             opt = Optional, 
                                             tp = Type} | Rest], Namespaces, DeclaredNamespaces) ->
  NameAsString = atom_to_list(Name),
  {NamespacesString, NewDeclaredNamespaces} = processNamespaces(NameAsString, Namespaces, DeclaredNamespaces),
  AttributeValue = element(SequenceNr + 2, Struct),
  case AttributeValue of
    undefined ->
      if 
        Optional ->
          processAttributes(Struct, ResultSoFar, Rest, Namespaces, DeclaredNamespaces);
	true ->
          throw({error, "No value provided for mandatory attribute " ++ atom_to_list(Name)})
      end;
    _Defined -> 
      case Type of
        
        char ->
          DeclaredNamespaces2 = NewDeclaredNamespaces,
          NamespacesString2 = NamespacesString,
          CharValue = xmlString(AttributeValue);
        integer ->
          DeclaredNamespaces2 = NewDeclaredNamespaces,
          NamespacesString2 = NamespacesString,
          CharValue = try integer_to_list(AttributeValue) 
          catch 
            _AnyClass:_Any ->
              throw({error, "Wrong Type in attribute  " ++ atom_to_list(Name) ++ ", expected Integer"})
          end;
        bool ->
          DeclaredNamespaces2 = NewDeclaredNamespaces,
          NamespacesString2 = NamespacesString,
          CharValue = case AttributeValue of
                        true -> "true";
                        false -> "false";
                        _ -> throw({error, "Wrong Type in attribute  " ++ atom_to_list(Name) ++ ", expected boolean"})
                      end;
        float ->
          DeclaredNamespaces2 = NewDeclaredNamespaces,
          NamespacesString2 = NamespacesString,
          CharValue = try float_to_list(AttributeValue) 
          catch 
            _AnyClass:_Any ->
              throw({error, "Wrong Type in attribute  " ++ atom_to_list(Name) ++ ", expected Float"})
          end;
        atom ->
          DeclaredNamespaces2 = NewDeclaredNamespaces,
          NamespacesString2 = NamespacesString,
          CharValue = try atom_to_list(AttributeValue) 
          catch 
            _AnyClass:_Any ->
              throw({error, "Wrong Type in attribute  " ++ atom_to_list(Name) ++ ", expected Atom"})
          end;
        qname ->
          writeQnameAttValue(AttributeValue, NamespacesString, Namespaces, NewDeclaredNamespaces),
          {CharValue, NamespacesString2, DeclaredNamespaces2} = 
             try writeQnameAttValue(AttributeValue, NamespacesString, Namespaces, NewDeclaredNamespaces)
          catch
            _AnyClass:_Any -> 
              throw({error, "Wrong Type in attribute " ++ atom_to_list(Name) ++ ", expected qname"})
          end;
        _Else ->
          throw({error, "unknown type in model"}),
          DeclaredNamespaces2 = NewDeclaredNamespaces,
          NamespacesString2 = NamespacesString,
          CharValue = []
      end,
      ResultWithThisAttribute = ResultSoFar ++ NamespacesString2 ++ " " ++ NameAsString ++ "=\"" ++ CharValue ++ "\" ",
      processAttributes(Struct, ResultWithThisAttribute, Rest, Namespaces, DeclaredNamespaces2)
  end.

%% returns:
%% {AttributeValue, NamespacesString, NewDeclaredNamespaces}
%% -record(qname, {uri, localPart, prefix, mappedPrefix}).
writeQnameAttValue(#qname{uri = Uri, localPart = LP, mappedPrefix = MP}, NamespacesString, Namespaces, 
                   DeclaredNamespaces = {NamespacesList, Counter}) ->
  case Uri of 
    [] ->
      {LP, NamespacesString, DeclaredNamespaces};
    _ ->
      %% see whether the namespace has been defined. If not, then this has to be done.
      case lists:keysearch(Uri, 2, NamespacesList) of
        {value, {Prefix, _Uri}} -> %% already declared
          {Prefix ++ ":" ++ LP, NamespacesString, DeclaredNamespaces};
        _ ->
          %% see whether a prefix was specified
          case lists:keysearch(Uri, #ns.uri, Namespaces) of
            {value, #ns{prefix = Prefix2}} ->
              {Prefix2 ++ ":" ++ LP, NamespacesString ++ " xmlns:" ++  Prefix2 ++ "=\"" ++ Uri ++ "\"", 
               {[{Prefix2, Uri} | NamespacesList], Counter}};
            _ ->
              {MP ++ ":" ++ LP, NamespacesString ++ " xmlns:" ++  MP ++ "=\"" ++ Uri ++ "\"", 
               {[{MP, Uri} | NamespacesList], Counter}}
          end
      end
  end.

          
processAnyAttributes(undefined, Acc, _Namespaces, DeclaredNamespaces) ->
  {Acc, DeclaredNamespaces};
processAnyAttributes([], Acc, _Namespaces, DeclaredNamespaces) ->
  {Acc, DeclaredNamespaces};
processAnyAttributes([{{Name, Uri}, Value} | Tail], Acc, Namespaces, DeclaredNamespaces) ->
  case Uri of
    [] -> 
      processAnyAttributes(Tail, Acc ++ " " ++ Name ++ "=\"" ++ Value ++ "\"", Namespaces, DeclaredNamespaces);
    _Other ->
     %% get prefix +, if relevant, NS declaration text
     {PrefixedName, DeclaredNamespaces2} = processAnyNamespaces(Name, Uri, Namespaces, DeclaredNamespaces),
     processAnyAttributes(Tail, Acc ++ " " ++ PrefixedName ++ "=\"" ++ Value ++ "\"", Namespaces, DeclaredNamespaces2)
  end.

%% see if the tag references a namespace. If so, see whether
%% this namespace has been declared.
%%
%% Namespaces is of the form {Prefix, URI}
%% DeclaredNamespaces = [Prefix]
%%
%% returns {NameSpacesString, NewDeclaredNamespaces}, where
%% NamespacesString is the declaration (if required), and
%% NewDeclaredNamespaces is the new list of declared 
%% namespaces.
processNamespaces(Tag, Namespaces, DeclaredNamespaces = {NamespacesList, Counter}) ->
  %% look for ':' in the tag
  %% debug(Tag),
  %% debug(DeclaredNamespaces),
  case string:tokens(Tag, ":") of
    [Prefix, _LName] ->
      %% declaredNamespaces = [{Prefix, Uri}]
      case lists:keysearch(Prefix, 1, NamespacesList) of
        {value, _} -> %% already declared
	  {[], DeclaredNamespaces};
	_Else ->
	  %% find prefix in Model
          case lists:keysearch(Prefix, 3, Namespaces) of
            {value, #ns{uri = Uri}} ->
	      {" xmlns:" ++  Prefix ++ "=\"" ++ Uri ++ "\"", {[{Prefix, Uri} | NamespacesList], Counter}};
	    _Else ->
              case Prefix of
                "xml" -> {[], DeclaredNamespaces};
                _ -> throw({error, "Inconsistency in model: namespace is not declared - " ++ Prefix})
              end
	  end
       end;
    [_LName] ->
      {[], DeclaredNamespaces};
    _Else ->
       throw({error, "Tag " ++ Tag ++ " is not of form [prefix:]localName"})
  end.

%%processAnyNamespaces(Name, Uri, Namespaces, {NamespacesList, Counter} = DeclaredNamespaces ) ->
processAnyNamespaces(Name, Uri, Namespaces, {NamespacesList, Counter} = DeclaredNamespaces ) ->
  case lists:keysearch(Uri, 2, NamespacesList) of
    {value, {Prefix, _}} -> %% already declared
      {Prefix ++ ":" ++ Name, DeclaredNamespaces};
    _Else ->
      %% find Uri in Model
      case lists:keysearch(Uri, #ns.uri, Namespaces) of
        {value, #ns{prefix = ModelPrefix}} ->
          ThePrefix = ModelPrefix;
        _Else ->
          %% make up a prefix, using counter
          ThePrefix = "pre" ++ integer_to_list(Counter +1)
      end,
      {" xmlns:" ++  ThePrefix ++ "=\"" ++ Uri ++ "\" " ++ ThePrefix ++ ":" ++ Name , 
          {[{ThePrefix, Uri} | NamespacesList], Counter + 1}}
  end.

printValue(CurrentValue, Alternatives, Namespaces, DeclaredNamespaces) ->
  case CurrentValue of 
    #qname{localPart = LocalName, prefix = Prefix} ->
      case lists:keysearch({'#PCDATA', qname}, #alt.tp, Alternatives) of
        {value, #alt{tag = Tag, rl = RealElement}} ->  %% Print Tags if RealElement
          if 
            Prefix == undefined ->
              TextValue = xmlString(LocalName);
            true ->
              TextValue = xmlString(Prefix ++ ":" ++ LocalName)
          end,
	  printElement(TextValue, Tag, RealElement, Namespaces, DeclaredNamespaces);
	_Else ->
          throw({error, "Type of value (qname) does not match model"})
      end;
   
    _B when is_list(CurrentValue) -> 
      case lists:keysearch({'#PCDATA', char}, #alt.tp, Alternatives) of
        {value, #alt{tag = Tag, rl = RealElement}} ->  %% Print Tags if RealElement
          TextValue = xmlString(CurrentValue),
	  printElement(TextValue, Tag, RealElement, Namespaces, DeclaredNamespaces);
	_Else ->
          throw({error, "Type of value (list) does not match model"})
      end;

    _C when is_integer(CurrentValue) ->
      %% is an integer also a float?
      case lists:keysearch({'#PCDATA', integer}, #alt.tp, Alternatives) of
        {value, #alt{tag = Tag, rl = RealElement}} ->
          TextValue = try integer_to_list(CurrentValue) 
          catch 
            _AnyClass:_Any ->
              throw({error, "Wrong Type"})
          end,
	  printElement(TextValue, Tag, RealElement, Namespaces, DeclaredNamespaces);
	_Else -> 
          throw({error, "Type of value (integer) does not match model"})
      end;

    _D when is_float(CurrentValue) ->
      %% is an integer also a float?
      case lists:keysearch({'#PCDATA', float}, #alt.tp, Alternatives) of
        {value, #alt{tag = Tag, rl = RealElement}} ->
          TextValue = try float_to_list(CurrentValue) 
          catch 
            _AnyClass:_Any ->
              throw({error, "Wrong Type"})
          end,
	  printElement(TextValue, Tag, RealElement, Namespaces, DeclaredNamespaces);
	_Else -> 
          throw({error, "Type of value (float) does not match model"})
      end;

    _E when CurrentValue ==  true; CurrentValue == false ->
      %% is an integer also a float?
      case lists:keysearch({'#PCDATA', bool}, #alt.tp, Alternatives) of
        {value, #alt{tag = Tag, rl = RealElement}} ->
          TextValue = try atom_to_list(CurrentValue) 
          catch 
            _AnyClass:_Any ->
              throw({error, "Wrong Type"})
          end,
	  printElement(TextValue, Tag, RealElement, Namespaces, DeclaredNamespaces);
	_Else -> 
          throw({error, "Type of value (atom) does not match model"})
      end;

    _Else -> 
      throw({error, "Type of value not valid for XML structure"})

  end.

printElement(TextValue, Tag, RealElement, Namespaces, DeclaredNamespaces) ->
  if
    RealElement ->
       TagAsText = atom_to_list(Tag),
       %% this function is only used in 'leaves' of the struct, so we don't need to store the 
       %% new declared namespaces (since those would apply only to child-elements, of 
       %% which there are none)
       {NamespacesString, _} = processNamespaces(TagAsText, Namespaces, DeclaredNamespaces),
       "<" ++ TagAsText ++ NamespacesString ++ ">" ++ TextValue ++ "</" ++ TagAsText ++ ">";
    true -> 
       TextValue
  end.

%% NOTE: this function is copied form DOM.ERL - it should be in a separate module
%% returns a string with & replaced by &amp; and " by &quot;
%% might be faster to parse the strings? 
xmlString(String) ->
  {ok, String2, _} = regexp:gsub(String, "&", "\\&amp;"),
  {ok, String3, _} = regexp:gsub(String2, "<", "\\&lt;"), 
  {ok, String4, _} = regexp:gsub(String3, ">", "\\&gt;"),
  {ok, Result, _} = regexp:gsub(String4, "\"", "\\&quot;"),
  Result.
